home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0003_BITFONTS.PAS.pas < prev    next >
Pascal/Delphi Source File  |  1993-05-28  |  17KB  |  627 lines
  1. {
  2. >I need to Write some Pascal code For a PC that will allow Text mode
  3. >fonts to be changed (at least on PC's With VGA adapters).
  4.  
  5. >Prof. Salmi's FAQ lists a book by Porter and Floyd, "Stretching
  6. >Turbo Pascal", as having the relevant information, but my local
  7. >bookstore claims this is out of print.
  8.  
  9. You could try borrowing the book from the library.  For instance ours
  10. will search For books; I rarely buy books.  STP:v5.5 was an exception.
  11. Here is code (substantially based on Porter and Floyds' code) written
  12. for version 5.x .  Actually, aside from this stuff, the book wasn't as
  13. good as I thought it would be.  I believe Ken Porter died and parts of
  14. the book seem missing.  This code, For instance, isn't well documented
  15. in the book (althought I think its clear how to use it from these
  16. Programs).
  17.  
  18. You know, after playing With this code I thought I knew it all :D
  19. It turns out that there is a lot more you can do.  For instance, the
  20. intensity bit can be used as an extra Character bit to allow
  21. 512-Character fonts.  I have an aging PC Magazine article (that I
  22. haven't gotten around to playing with) that has some Asm code For the
  23. EGA.  (I'm hoping the same code will work For the VGA).
  24. }
  25. {--[rounded.pas]--}
  26.  
  27. Program
  28.   Rounded;
  29. Uses
  30.   Crt, BitFonts;
  31.  
  32. Type
  33.   matrix = Array[0..15] of Byte;
  34.  
  35. Const
  36.   URC : matrix = ($00,$00,$00,$00,$00,$00,$00,$C0,$70,$30,$18,$18,$18,$18,$18,$18);
  37.   LLC : matrix = ($18,$18,$18,$18,$0C,$0E,$03,$00,$00,$00,$00,$00,$00,$00,$00,$00);
  38.   LRC : matrix = ($18,$18,$18,$18,$30,$70,$C0,$00,$00,$00,$00,$00,$00,$00,$00,$00);
  39.   ULC : matrix = ($00,$00,$00,$00,$00,$00,$00,$03,$0E,$0C,$18,$18,$18,$18,$18,$18);
  40. {  ULC : matrix = ($00,$00,$00,$00,$00,$03,$0E,$19,$33,$36,$36,$36,$36,$36,$36,$36);}
  41. Var
  42.   index,b      : Word;
  43.   package      : fontPackagePtr;
  44.   FontFile     : File of FontPackage;
  45.   EntryFont    : ROMfont;
  46.  
  47.   Procedure TextBox( left, top, right, bottom, style : Integer );
  48.     Const
  49.       bord : Array[1..2,0..5] of Char = ( ( #196,#179,#218,#191,#217,#192 ),
  50.                                           ( #205,#186,#201,#187,#188,#200 ));
  51.     Var P:Integer;
  52.  
  53.     begin
  54.       if Style = 0 then Exit; { what the fuck is this For ? }
  55.  
  56.       { verify coordinates are in ( NW,SE ) corner }
  57.       if left > right then
  58.         begin
  59.           p := left; left := right; right := p;
  60.         end;
  61.       if bottom < top then
  62.         begin
  63.           p := top; top := bottom; bottom := p;
  64.         end;
  65.  
  66.       { draw top }
  67.       GotoXY( left,top );
  68.       Write( bord[style,2] );
  69.       For p := left+1 to right-1 do
  70.         Write( bord[style,0]);
  71.       Write( bord[style,3] );
  72.  
  73.       { draw bottomm }
  74.       GotoXY( left,bottom );
  75.       Write( bord[style,5]);
  76.       For p := left+1 to right-1 do
  77.         Write( bord[style,0]);
  78.       Write( bord[style,4]);
  79.  
  80.       { draw sides }
  81.       For p := top+1 to bottom-1 do
  82.         begin
  83.           GotoXY( left,p );
  84.           Write( bord[style,1] );
  85.           GotoXY( right,p );
  86.           Write( bord[style,1] );
  87.         end;
  88.     end; { Procedure TextBox }
  89.  
  90.   Procedure replace( ASCII:Word; newChar:matrix );
  91.     Var offset,b:Word;
  92.     begin
  93.       offset := ASCII * VDA.points;
  94.       For b := 0 to VDA.points-1 do
  95.         package^.ch[offset+b] := newChar[b];
  96.     end;
  97.  
  98. begin
  99.   if not isEGA then
  100.     begin
  101.       Writeln( 'You can only run this Program on EGA or VGA systems' );
  102.       halt( 1 );
  103.     end;
  104.   {- fetch copy of entry font -}
  105.   EntryFont := CurrentFont;
  106.   Package := FetchHardwareFont( CurrentFont );
  107.  
  108.   {- replace the corner Characters -}
  109.   replace( 191,URC );
  110.   replace( 192,LLC );
  111.   replace( 217,LRC );
  112.   replace( 218,ULC );
  113.  
  114.   {- load and active user-modified font -}
  115.   Sound( 1000 );
  116.   LoadUserFont( package );
  117.   NoSound;
  118.  
  119.   {- Draw a Text box -}
  120.   ClrScr;
  121. {  CursorOff; }
  122.   TextBox( 20,5,60,20,1 );
  123.   GotoXY( 33,12 ); Write( 'rounded corners' );
  124. {  WaitForKey;}
  125.   readln;
  126.  
  127.   {- save user-modified font to File -}
  128.   assign( FontFile, 'HELLO' );
  129.   reWrite( FontFile );
  130.   Write( FontFile,Package^ );
  131.   close( FontFile );
  132.  
  133.   {- clear and quit -}
  134.   SetHardWareFont( EntryFont );
  135.   ClrScr;
  136. {  CursorOn;}
  137.  
  138. end.
  139.  
  140. {--[editfnt2.pas]--}
  141.  
  142. Program EditFont;
  143.  
  144. Uses Crt, Dos, BitFonts;
  145.  
  146. Const
  147.   Block = #220;
  148.   Esc = #27;
  149. Var
  150.   c,
  151.   Choice : Char;
  152.   EditDone,
  153.   Done,
  154.   Valid  : Boolean;
  155.   Font   : ROMfont;
  156.   package : FontPackagePtr;
  157.   fout : File of FontPackage;
  158.   foutfil : String;
  159.  
  160. Function UpperCase( s:String ): String;
  161.   Var i:Byte;
  162.   begin
  163.     For i := 1 to length( s ) do
  164.       s[i] := UpCase( s[i] );
  165.     UpperCase := s;
  166.   end;
  167.  
  168.  
  169. Function HexByte( b:Byte ):String;
  170.   Const DIGIT : Array[0..15] of Char = '0123456789ABCDEF';
  171.   begin
  172.     HexByte := Digit[b SHR 4] + Digit[b and $0F];
  173.   end;
  174.  
  175.  
  176. Function ByteBin( Var bs:String ):Byte;
  177.   Const DIGIT : Array[0..15] of Char = '0123456789ABCDEF';
  178.   Var i,b:Byte;
  179.   begin
  180.     b := 0;
  181.     For i := 2 to length( bs ) do
  182.       if bs[i] = '1' then
  183.         b := b + 2 SHL (i-1);
  184.     if bs[1] = '1' then
  185.       b := b + 1;
  186.     ByteBin := b;
  187.   end;
  188.  
  189.  
  190. Procedure Browse( Font:ROMfont );
  191.  
  192. {
  193.     arrow keys to manuever
  194.     Esc to accept
  195.     Enter or space to toggle bit
  196.     C or c to clear a row
  197.     alt-C or ctl-C to clear whole Char
  198.  
  199. }
  200.   Const
  201.     MapRow = ' - - - - - - - - ';
  202.     MapTop = 7;
  203.  
  204.   Var
  205.     ASCII,
  206.     row,
  207.     col,
  208.     index,
  209.     bit   : Word;
  210.     f     : Char_table;
  211.     s     : String;
  212.     error : Integer;
  213.  
  214.   Procedure putChar( value:Word );
  215.     Var reg:Registers;
  216.     begin
  217.       reg.AH := $0A;
  218.       reg.AL := Byte( value );
  219.       reg.BH := 0;
  220.       reg.BL := LightGray;
  221.       reg.CX := 1;
  222.       intr( $10,reg );
  223.       GotoXY( WhereX+1, WhereY );
  224.     end; { proc putChar }
  225.  
  226.   begin
  227.     GetMem( Package, SizeOf( Package^ ));
  228.     ClrScr;
  229.     Package := FetchHardwareFont( Font );
  230.     Repeat
  231.       GotoXY( 1,1 );
  232.       Write( 'FONT: ' );
  233.       Case Font of
  234.         ROM8x8  : Writeln( '8 x 8' );
  235.         ROM8x14 : Writeln( '8 x 14' );
  236.         ROM8x16 : Writeln( '8 x 16' );
  237.       end;
  238.       Writeln;
  239.       clreol;
  240.       Write( 'ASCII value to examine? (or QUIT to quit) ' );
  241.       readln( s );
  242.       Val( s,ASCII,error );
  243.       if error <> 0 then
  244.         if UpperCase( s ) = 'QUIT' then
  245.           Done := True
  246.         else
  247.           ASCII := Byte( s[1] );
  248.  
  249.       { show the Character image }
  250.       clreol;
  251.       Write( '(Image For ASCII ',ASCII,' is ' );
  252.       putChar( ASCII );
  253.       Writeln( ')' );
  254.  
  255.       { display blank bitmap }
  256.       GotoXY( 1,MapTop );
  257.       For row := 1 to Package^.FontInfo.points do
  258.         Writeln( maprow );
  259.  
  260.       { explode the image bitmap }
  261.       index := Package^.FontInfo.points * ASCII;
  262.       For row := 0 to Package^.FontInfo.points-1 do
  263.         begin
  264.           For bit := 0 to 7 do
  265.             if (( Package^.Ch[index] SHR bit ) and 1 ) = 1 then
  266.               begin
  267.                 col := ( 8 - bit ) * 2;
  268.                 GotoXY( col,row+MapTop );
  269.                 Write( block );
  270.               end;
  271.           GotoXY( 20,row+MapTop );
  272.           Write( hexByte( Package^.Ch[index] )+ 'h' );
  273.           inc( index );
  274.         end;
  275.  
  276.  
  277.       { edit font }
  278.       col := 2;
  279.       row := MapTop;
  280.       EditDone := False;
  281.       index := Package^.FontInfo.points * ASCII;
  282.  
  283.       While ( not Done ) and ( not EditDone ) do
  284.         begin
  285.           GotoXY( col,row );
  286.           c := ReadKey;
  287.           if c = #0 then
  288.             c := ReadKey;
  289.  
  290.           Case c of
  291.  
  292.             #03,         { wipe entire letter }
  293.             #46 : begin
  294.                     index := Package^.FontInfo.points * ASCII;
  295.                     For row := MapTop to MapTop+Package^.FontInfo.points-1 do
  296.                       begin
  297.                         Package^.Ch[index] := 0;
  298.                         col := 2;
  299.                         GotoXY( col,row );
  300.                         Write( '- - - - - - -' );
  301.                         GotoXY( 20,row );
  302.                         Write( hexByte( Package^.Ch[index] )+ 'h' );
  303.                         GotoXY( col,row );
  304.                         inc( index );
  305.                       end;
  306.                   end;
  307.  
  308.             'C',         { wipe row }
  309.             'c' : begin
  310.                     Package^.Ch[index] := 0;
  311.                     col := 2;
  312.                     GotoXY( col,row );
  313.                     Write( '- - - - - - -' );
  314.                     GotoXY( 20,row );
  315.                     Write( hexByte( Package^.Ch[index] )+ 'h' );
  316.                     GotoXY( col,row );
  317.                   end;
  318.  
  319.  
  320.             #27 : EditDone := True;  { esc }
  321.  
  322.             #72 : begin  { up }
  323.                     if row >  MapTop then
  324.                       begin
  325.                         dec( row );
  326.                         dec( index );
  327.                       end;
  328.                   end;
  329.  
  330.             #80 : begin  { down }
  331.                     if row < ( MapTop + Package^.FontInfo.points - 1 ) then
  332.                       begin
  333.                         inc( row );
  334.                         inc( index );
  335.                       end;
  336.                   end;
  337.  
  338.             #77 : begin  { right }
  339.                     if col < 16 then
  340.                       inc( col,2 );
  341.                   end;
  342.  
  343.             #75 : begin  { left }
  344.                     if col > 3 then
  345.                       dec( col,2 );
  346.                   end;
  347.  
  348.             #13,
  349.             #10,
  350.             ' ' : begin
  351.                     bit := 8 - ( col div 2 );
  352.                     if (( Package^.Ch[index] SHR bit ) and 1 ) = 1 then
  353.                       begin
  354.                         Package^.Ch[index] := ( Package^.Ch[index] ) AND
  355.                                                ($FF xor ( 1 SHL bit ));
  356.                         Write( '-' )
  357.                       end
  358.                     else
  359.                       begin
  360.                         Package^.Ch[index] := Package^.Ch[index] XOR
  361.                                               ( 1 SHL bit );
  362.                         Write( block );
  363.                       end;
  364.  
  365.                     GotoXY( 20,row );
  366.                     Write( hexByte( Package^.Ch[index] )+ 'h' );
  367.                     GotoXY( col,row );
  368.                   end;
  369.  
  370.           end; { Case }
  371.  
  372.           LoadUserFont( Package );
  373.  
  374.         end; { While }
  375.  
  376.     Until Done;
  377.  
  378.     GotoXY( 40,7 );
  379.     Write( 'Save to disk? (Y/n) ');
  380.     Repeat
  381.       c := UpCase( ReadKey );
  382.     Until c in ['Y','N',#13];
  383.     if c = #13 then
  384.       c := 'Y';
  385.     Write( c );
  386.  
  387.     if c = 'Y' then
  388.       begin
  389.         GotoXY( 40,9 );
  390.         ClrEol;
  391.         Write( 'Save as: ');
  392.         readln( foutfil );
  393.  
  394. (*        if fexist( foutfil ) then
  395.           begin
  396.             GotoXY( 40,7 );
  397.             Write( 'OverWrite File ''',foutfil,''' (y/N) ');
  398.             Repeat
  399.               c := UpCase( ReadKey );
  400.             Until c in ['Y','N',#13];
  401.             if c = #13 then
  402.               c := 'N';
  403.             Write( c );
  404.           end;
  405. *)
  406.         {$I-}
  407.         assign( fout,foutfil ); reWrite( fout );
  408.         Write( fout,Package^ );
  409.         close( fout );
  410.         {$I+}
  411.         GotoXY( 40,11 );
  412.         if ioResult <> 0 then
  413.           Writeln( 'Write failed!' )
  414.         else
  415.           Writeln( 'Wrote font to File ''',foutfil,'''.' );
  416.       end;
  417.  
  418.  
  419.   end; { proc Browse }
  420.  
  421.  
  422. begin
  423.  
  424.   Done := False;
  425.   { get font to view }
  426.   Repeat
  427.     Valid := False;
  428.     Repeat
  429.       ClrScr;
  430.       Writeln( 'Fonts available For examination: ' );
  431.       Writeln( '    1. 8 x 8' );
  432.       if isEGA then
  433.  
  434.         Writeln( '    2. 8 x 14' );
  435.       if isVGA then
  436.         Writeln( '    3. 8 x 16' );
  437.       Writeln;
  438.       Write( '    Select by number (or Esc to quit) ' );
  439.       choice := ReadKey;
  440.       if Choice = Esc then
  441.         begin
  442.           ClrScr;
  443.           Exit;
  444.         end;
  445.       if Choice = '1' then Valid := True;
  446.       if ( choice = '2' ) and isEGA then Valid := True;
  447.       if ( Choice = '3' ) and isVGA then Valid := True;
  448.     Until Valid;
  449.  
  450.     { fetch and display selected font }
  451.     Case choice of
  452.       '1' : Font := ROM8x8;
  453.       '2' : Font := ROM8x14;
  454.       '3' : Font := ROM8x16;
  455.     end;
  456.     Browse( font );
  457.   Until Done;
  458.   GotoXY( 80,25 );
  459.   Writeln;
  460.   Writeln( 'Thanks you For using EditFont which is based on code from' );
  461.   Writeln( '_Stretching Turbo Pascal_ by Kent Porter and Mike Floyd.' );
  462.   Writeln;
  463.   Writeln( 'This Program was developed 12 Apr 92 by Alan D. Mead.' );
  464. end.
  465.  
  466. {--[bitfonts.pas]--}
  467.  
  468.  
  469. Unit BitFonts;
  470.   { support For bit-mapped Text fonts on EGA/VGA }
  471.  
  472. Interface
  473.  
  474. Type
  475.               { enumeration of ROM hardware fonts }
  476.   ROMfont = ( ROM8x14, ROM8x8, ROM8x16 );
  477.  
  478.               { Characetr definition table }
  479.   CharDefTable = Array[0..4095] of Byte;
  480.   CharDefPtr   = ^CharDefTable;
  481.  
  482.               { For geting Text Character generators }
  483.   Char_table = Record
  484.                  points : Byte;       { Char matrix height }
  485.                  def    : CharDefPtr; { address of table }
  486.                end;
  487.  
  488.               { font format }
  489.   FontPackage = Record
  490.                   FontInfo : Char_Table;
  491.                   ch       : CharDefTable;
  492.                 end;
  493.   FontPackagePtr = ^FontPackage;
  494.  
  495.               { table maintained by video ROM BIOS at 40h : 84h }
  496.   VideoDataArea = Record
  497.                     rows   : Byte;  { Text rows on screem - 1 }
  498.                     points : Word;    { height of Char matrix }
  499.                     info,               { EGA/VGA status info }
  500.                     info_3,           { EGA/VGA configuration }
  501.                     flags  : Word;               { misc flags }
  502.                   end;           { remainder of table ignored }
  503.  
  504.               { globally visible }
  505. Var
  506.   VDA         : VideoDataArea Absolute $40:$84;   { equipment flags }
  507.   isEGA,
  508.   isVGA,
  509.   isColor     : Boolean;
  510.   CurrentFont : ROMfont; { default hardware font }
  511.  
  512. Procedure GetCharGenInfo( font:ROMfont; Var table:Char_table );
  513. Procedure SetHardWareFont( font:ROMfont );
  514. Function FetchHardwareFont( font:ROMfont ):FontPackagePtr;
  515. Procedure LoadUserFont( pkg:FontPackagePtr );
  516.  
  517. { - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  518.  
  519. Implementation
  520.  
  521. Uses Dos, Crt {, TextScrn} ;
  522.  
  523. Var reg:Registers;
  524.  
  525. Procedure GetCharGenInfo( font:ROMfont; Var table:Char_table );
  526.   begin
  527.     if isEGA then
  528.       begin
  529.         reg.AH := $11;
  530.         reg.AL := $30;
  531.         Case font of
  532.           ROM8x8  : reg.BH := 3;
  533.           ROM8x14 : reg.BH := 2;
  534.           ROM8x16 : reg.BH := 6;
  535.         end;
  536.         intr( $10,reg );
  537.         table.def := ptr( reg.ES,reg.BP ); { address of definition table }
  538.         Case font of
  539.           ROM8x8  : table.points :=  8;
  540.           ROM8x14 : table.points := 14;
  541.           ROM8x16 : table.points := 16;
  542.         end;
  543.       end;
  544.   end; { proc GetCharGenInfo }
  545.  
  546.  
  547. Procedure SetHardWareFont( font:ROMfont );
  548.   begin
  549.     if isEGA then
  550.       begin
  551.         Case Font of
  552.           ROM8x14 : reg.AL := $11;
  553.           ROM8x8  : reg.AL := $12;
  554.           ROM8X16 : if isVGA then
  555.                       reg.AL := $14
  556.                     else
  557.                       begin
  558.                         reg.AL := $12;
  559.                         font := ROM8x14;
  560.                       end;
  561.         end;
  562.         reg.BL := 0;
  563.         intr( $10,reg );
  564.         CurrentFont := font;
  565.       end;
  566.   end; { proc SetHardwareFont }
  567.  
  568.  
  569. Function FetchHardwareFont( font:ROMfont ):FontPackagePtr;
  570.   { Get a hardware font and place it on heap For user modification }
  571.   Var pkg : FontPackagePtr;
  572.   begin
  573.     new( pkg );
  574.     GetCharGenInfo( font,pkg^.fontinfo );
  575.     pkg^.ch := pkg^.fontinfo.def^;
  576.     FetchHardwareFont := pkg;
  577.   end; { func FetchHardwareFont }
  578.  
  579.  
  580. Procedure LoadUserFont( pkg:FontPackagePtr );
  581.   begin
  582.     reg.AH := $11;
  583.     Reg.AL := $10;
  584.     reg.ES := seg( pkg^.ch );
  585.     reg.BP := ofs( pkg^.ch );
  586.     reg.BH := pkg^.FontInfo.points;
  587.     reg.BL := 0;
  588.     reg.CX := 256;
  589.     reg.DX := 0;
  590.     intr( $10,reg );
  591.   end; { proc LoadUserFont }
  592.  
  593.  
  594. begin  { initialize }
  595.  
  596.   { determine adapter Type }
  597.   isEGA := False;
  598.   isVGA := False;
  599.   if VDA.info <> 0 then
  600.     begin
  601.       isEGA := True;
  602.       if ( VDA.flags and 1 ) = 1 then
  603.         isVGA := True;
  604.     end;
  605.  
  606.   { determine monitor Type }
  607.   if isEGA then
  608.     begin
  609.       reg.AH := $12;
  610.       reg.BL := $10;
  611.       intr( $10,reg );
  612.       if reg.BH = 0 then
  613.         isCOLOR := True
  614.       else
  615.         isCOLOR := False;
  616.                                    { ADM: this seems Really shaky! }
  617.       { determine current font }
  618.       if isVGA and ( VDA.rows = 24 ) then
  619.         CurrentFont := ROM8x16
  620.       else
  621.         if isEGA and ( VDA.rows = 24 ) then
  622.           CurrentFont := ROM8x14
  623.         else
  624.           CurrentFont := ROM8x8;
  625.     end
  626. end.
  627.